home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 011 / autodesk.arc / 3D.LSP next >
Encoding:
Lisp/Scheme  |  1987-09-02  |  11.0 KB  |  369 lines
  1.  
  2. ; 3D cones, domes, dishes, spheres, and tori for AutoCAD 2.6 and later
  3.  
  4. ; by Simon Jones - Autodesk UK Ltd.
  5. ; and Duff Kurland - Autodesk, Inc.
  6. ; November, 1986
  7.  
  8. ; Combined into a single "3D" command  -  July, 1987
  9.  
  10.  
  11. (setq hemisphere nil                  ; Allow easier reloads
  12.       domsph     nil
  13.       torus      nil
  14.       cone       nil
  15.       3seg       nil
  16.       4seg       nil
  17.       myerror    nil
  18.       C:3D       nil)
  19.  
  20.  
  21. ; Syetem variable save
  22.  
  23. (defun modes (a)
  24.    (setq MLST nil)
  25.    (repeat (length a)
  26.       (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
  27.       (setq a (cdr a)))
  28. )
  29.  
  30.  
  31. ; Syetem variable restore
  32.  
  33. (defun moder ()
  34.    (repeat (length MLST)
  35.       (setvar (caar MLST) (cadar MLST))
  36.       (setq MLST (cdr MLST))
  37.    )
  38. )
  39.  
  40.  
  41. ; Convert degrees to radians
  42.  
  43. (defun dtr (a)
  44.    (* pi (/ a 180.0))
  45. )
  46.  
  47.  
  48. ; Calculate new radius for dome/dish/sphere
  49.  
  50. (defun calc-r (y)
  51.    (sqrt (- (* rad rad) (* y y)))
  52. )
  53.  
  54.  
  55. ; Select all entities added since checkpoint.
  56.  
  57. (defun selstuff (e)
  58.    (setq ss nil)                      ; Free old selection-set if present
  59.    (setq ss (ssadd))                  ; Form empty selection-set
  60.    (if (null e)                       ; No previous stuff in drawing?
  61.        (setq ss (ssadd (setq e (entnext)) ss))  ; Start with what we drew
  62.    )
  63.    (while (setq e (entnext e))        ; Scan until end of drawing
  64.        (setq ss (ssadd e ss))         ; Add each entity to selection-set
  65.    )
  66.    ss                                 ; Return selection-set
  67. )
  68.  
  69.  
  70. ; Form a 3-point cone face
  71.  
  72. (defun 3seg (/ pt2 pt3)
  73.    (setq pt2 (polar cen 0.0 rmax))
  74.    (setq pt3 (polar cen (dtr (/ 360.0 numseg)) rmax))
  75.    (command "3DFACE"
  76.             (list (car cen) (cadr cen) (+ elev h))
  77.             (list (car pt2) (cadr pt2) elev)
  78.             (list (car pt3) (cadr pt3) elev)
  79.             ""
  80.             ""
  81.    )
  82.    (setq doneface T)
  83. )
  84.  
  85.  
  86. ; Form a 4-point chopped-cone face
  87.  
  88. (defun 4seg (/ pt1 pt2 pt3 pt4)
  89.    (setq pt1 (polar cen 0.0 rmin))
  90.    (setq pt2 (polar cen 0.0 rmax))
  91.    (setq pt3 (polar cen (dtr (/ 360.0 numseg)) rmax))
  92.    (setq pt4 (polar cen (dtr (/ 360.0 numseg)) rmin))
  93.    (command "3DFACE"
  94.             (list (car pt1) (cadr pt1) (+ elev h))
  95.             (list (car pt2) (cadr pt2) elev)
  96.             (list (car pt3) (cadr pt3) elev)
  97.             (list (car pt4) (cadr pt4) (+ elev h))
  98.             ""
  99.    )
  100.    (setq doneface T)
  101. )
  102.  
  103.  
  104. ; Build upper or lower hemisphere from chopped cones with decreasing radii.
  105.  
  106. (defun hemisphere (which / baseelev h1 h2)
  107.    (setq h2 (/ rad 4.0))
  108.    (if (eq which "lower")             ; Doing lower hemisphere?
  109.        (setq h2 (- h2))               ; Yes, use negaitve height
  110.    )
  111.    (setq baseelev (caddr cen) elev baseelev h1 0 h (- h2 h1))
  112.    (while (> (* rad rad) (* h2 h2))
  113.        (setq rmax (calc-r h1) rmin (calc-r h2) h (- h2 h1))
  114.        (4seg)
  115.        (setq h1 h2 h2 (+ h2 (* h 0.85)))
  116.        (setq elev (+ elev h) h (- h2 h1))
  117.    )
  118.  
  119.    ; Now top it off.
  120.  
  121.    (setq rmax (calc-r h1))
  122.    (if (eq which "upper")
  123.       (setq h (- (+ baseelev rad) elev))
  124.       (setq h (- (- baseelev rad) elev))
  125.    )
  126.    (3seg)
  127. )
  128.  
  129.  
  130. ; Draw a 3D cone
  131.  
  132. (defun cone (/ cen elev h rmax rmin pt2 pt3 rad numseg)
  133.    (initget (+ 1 16))                 ; 3D point cannot be null
  134.    (setq elev (caddr (setq cen (getpoint "\nBase center point: "))))
  135.  
  136.    (initget 7 "Diameter")             ; Base radius can't be 0, neg, or null
  137.    (setq rmax (getdist cen "\n<Base radius>/Diameter: "))
  138.    (if (= rmax "Diameter")
  139.        (progn
  140.            (initget 7)                ; Base diameter can't be 0, neg, or null
  141.            (setq rmax (/ (getdist cen "\nBase diameter: ") 2.0))
  142.        )
  143.    )
  144.  
  145.    (initget 4 "Diameter")             ; Top radius cannot be negative
  146.    (setq rmin (getdist cen "\n<Top radius>/Diameter <0>: "))
  147.    (if (= rmin "Diameter")
  148.        (progn
  149.            (initget 4)                ; Top diameter cannot be negative
  150.            (setq rmin (getdist cen "\nTop diameter <0>: "))
  151.            (if rmin 
  152.                (setq rmin (/ rmin 2.0))
  153.            )
  154.        )
  155.    )
  156.  
  157.    (initget 3)                        ; Height cannot be zero or null
  158.    (setq h (getdist cen "\nHeight: "))
  159.  
  160.    (while (< numseg 3)
  161.        (initget 6)                    ; Cannot have zero or negative segs
  162.        (setq numseg (getint "\nNumber of segments <16>: "))
  163.        (if (null numseg)
  164.            (setq numseg 16)
  165.        )
  166.        (if (< numseg 3) (prompt "\nRequires at least 3 segments."))
  167.    )
  168.  
  169.    (setvar "BLIPMODE" 0)
  170.    (if rmin
  171.        (4seg)                         ; Chopped off point
  172.        (3seg)                         ; Full point
  173.    )
  174.    (command "ARRAY" (entlast) "" "Polar" cen numseg "360" "")
  175. )
  176.  
  177.  
  178. ; Generate a sphere or a hemisphere (dome/dish)
  179.  
  180. (defun domsph (which name / cen e numseg rad)
  181.    (setvar "THICKNESS" 0)
  182.    (initget (+ 1 16))                 ; Center point - 3d okay, cannot be null
  183.    (setq cen (getpoint (strcat "\n" name " center point: ")))
  184.  
  185.    (initget 7)                        ; Radius cannot be zero, neg, or null
  186.    (setq rad (getdist cen (strcat "\n" name " radius: ")))
  187.  
  188.    (while (or (< numseg 8) (> numseg 24))
  189.        (initget 6)                    ; Cannot have zero or negative segs
  190.        (setq numseg (getint "\nNumber of segments (8-24) <16>: "))
  191.        (if (null numseg)
  192.            (setq numseg 16)
  193.        )
  194.        (if (or (< numseg 8) (> numseg 24))
  195.            (prompt "\nOutside acceptable range.")
  196.        )
  197.    )
  198.  
  199.    (setvar "BLIPMODE" 0)
  200.    (setq e (entlast))                 ; Take database checkpoint
  201.    (if (= (logand which 1) 1)         ; If sphere or dome,
  202.        (hemisphere "upper")           ;   do upper hemisphere
  203.    )
  204.    (if (= (logand which 2) 2)         ; If sphere or dish,
  205.        (hemisphere "lower")           ;   do lower hemisphere
  206.    )
  207.    (command "ARRAY" (setq ss (selstuff e)) "" "Polar" cen numseg "360" "")
  208.    (setq ss nil)
  209. )
  210.  
  211.  
  212. ; Draw a torus
  213.  
  214. (defun torus (/ beta cen cosa deltal deltat e flop j numrseg numtseg
  215.                 px1 px2 px3 px4 
  216.                 py1 py2 py3 py4
  217.                 pz1 pz2 pz3 pz4
  218.                 radl radt sina x xorg yorg zorg)
  219.  
  220.    (initget (+ 1 16))                 ; Center point - 3D okay, cannot be null
  221.    (setq cen (getpoint "\nTorus center point: "))
  222.  
  223.    (setq radl -1 radt 0)
  224.    (while (> radt radl)
  225.        (initget 7 "Diameter")         ; Radius cannot be zero, neg, or null
  226.        (setq radl (getdist cen "\n<Torus radius>/Diameter: "))
  227.        (if (= radl "Diameter")
  228.            (progn
  229.                (initget 7)            ; Diameter cannot be zero, neg, or null
  230.                (setq radl (/ (getdist cen "\nTorus diameter: ") 2.0))
  231.            )
  232.        )
  233.  
  234.        (initget 7 "Diameter")         ; Radius cannot be zero, neg, or null
  235.        (setq radt (getdist cen "\n<Tube radius>/Diameter: "))
  236.        (if (= radt "Diameter")
  237.            (progn
  238.                (initget 7)            ; Diameter cannot be zero, neg, or null
  239.                (setq radt (/ (getdist cen "\nTube diameter: ") 2.0))
  240.            )
  241.        )
  242.        (if (> radt radl)
  243.            (prompt "\nTube radius cannot exceed torus radius.")
  244.        )
  245.    )
  246.  
  247.    (while (or (< numrseg 8) (> numrseg 24))
  248.        (initget 6)                    ; Cannot have zero or negative segs
  249.        (setq numrseg (getint "\nNumber of radial segments (8-24) <16>: "))
  250.        (if (null numrseg)
  251.            (setq numrseg 16)
  252.        )
  253.        (if (or (< numrseg 8) (> numrseg 24))
  254.            (prompt "\nOutside acceptable range.")
  255.        )
  256.    )
  257.  
  258.    (while (or (< numtseg 8) (> numtseg 24))
  259.        (initget 6)                    ; Cannot have zero or negative segs
  260.        (setq numtseg (getint "\nNumber of tube segments (8-24) <16>: "))
  261.        (if (null numtseg)
  262.            (setq numtseg 16)
  263.        )
  264.        (if (or (< numtseg 8) (> numtseg 24))
  265.            (prompt "\nOutside acceptable range.")
  266.        )
  267.    )
  268.  
  269.    (setvar "BLIPMODE" 0)
  270.    (setq e (entlast)                   ; Take database checkpoint
  271.          deltat (* 2.0 (/ pi numtseg))
  272.          deltal (* 2.0 (/ pi numrseg))
  273.          cosa (cos deltal)
  274.          sina (sin deltal)
  275.          xorg (car cen)
  276.          yorg (cadr cen)
  277.          zorg (caddr cen)
  278.          x (+ radl radt)
  279.          px1 (+ x xorg)
  280.          py1 yorg
  281.          pz1 zorg
  282.          px2 (+ xorg (* x cosa))
  283.          py2 (+ yorg (* x sina))
  284.          pz2 pz1
  285.    )
  286.    (command "3DFACE" (list px1 py1 pz1) (list px2 py2 pz2))
  287.  
  288.    (setq doneface T j 1 flop 0)
  289.    (while (<= j numtseg)
  290.        (setq beta (* j deltat)
  291.              x (+ radl (* radt (cos beta)))
  292.              px3 (+ xorg (* x cosa))
  293.              py3 (+ yorg (* x sina))
  294.              pz3 (+ zorg (* radt (sin beta)))
  295.              px4 (+ xorg x)
  296.              py4 yorg
  297.              pz4 pz3
  298.        )
  299.        (if (= 1 flop)
  300.            (command (list px4 py4 pz4) (list px3 py3 pz3))
  301.            (command (list px3 py3 pz3) (list px4 py4 pz4))
  302.        )
  303.        (setq flop (- 1 flop) j (+ j 1))
  304.    )
  305.    (command "")
  306.    (command "ARRAY" (setq ss (selstuff e)) "" "Polar" cen numrseg "360" "Y")
  307.    (setq ss nil)
  308. )
  309.  
  310.  
  311. ; Internal error handler
  312.  
  313. (defun myerror (s)                     ; If an error (such as CTRL-C) occurs
  314.                                        ; while this command is active...
  315.    (if (/= s "Function cancelled")
  316.        (princ (strcat "\nError: " s))
  317.    )
  318.    (if doneface
  319.        (progn                          ; If we're drawing 3DFACEs...
  320.            (command)                   ;   simulate CTRL-C (cancel 3DFACE cmd)
  321.            (command "UNDO" "End")      ;   terminate Undo group
  322.            (princ " ...undoing ")      ;   erase partially-drawn stuff
  323.            (command "U")
  324.        )
  325.    )
  326.    (moder)                             ; Restore modified modes
  327.    (setq ss nil)                       ; Free selection-set if any
  328.    (setq *error* olderr)               ; Restore old *error* handler
  329.    (princ)
  330. )
  331.  
  332.  
  333. (defun C:CONE ()   (3d "Cone"))
  334. (defun C:DISH ()   (3d "DIsh"))
  335. (defun C:DOME ()   (3d "DOme"))
  336. (defun C:SPHERE () (3d "Sphere"))
  337. (defun C:TORUS ()  (3d "Torus"))
  338. (defun C:3D ()     (3d nil))
  339.  
  340.  
  341. ; Main program.  Draws 3D object specified by "key" argument.
  342. ; If "key" is nil, asks which object is desired.
  343.  
  344. (defun 3d (key / doneface olderr ss)
  345.    (setq olderr   *error*
  346.          *error*  myerror
  347.          doneface nil)
  348.    (modes '("CMDECHO" "BLIPMODE" "HIGHLIGHT" "ELEVATION" "THICKNESS"))
  349.    (setvar "CMDECHO" 0)
  350.    (setvar "HIGHLIGHT" 0)
  351.    (if (null key)
  352.        (progn
  353.            (initget "Cone DIsh DOme Sphere Torus")
  354.            (prompt "\nSelect 3D utility.")
  355.            (setq key (getkword "\nCone/DIsh/DOme/Sphere/Torus: "))
  356.        )
  357.    )
  358.    (cond ((= key "Cone")   (cone))
  359.          ((= key "DIsh")   (domsph 2 "Dish"))
  360.          ((= key "DOme")   (domsph 1 "Dome base"))
  361.          ((= key "Sphere") (domsph 3 key))
  362.          ((= key "Torus")  (torus))
  363.          (T nil)                      ; Null reply?  Just exit
  364.    )
  365.    (moder)                            ; Restore saved modes
  366.    (setq *error* olderr)              ; Restore old *error* handler
  367.    (princ)
  368. )
  369.